home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / vm-tran.lisp < prev    next >
Encoding:
Text File  |  1991-11-16  |  10.7 KB  |  360 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: vm-tran.lisp,v 1.26 91/11/16 03:55:17 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: vm-tran.lisp,v 1.26 91/11/16 03:55:17 wlott Exp $
  15. ;;;
  16. ;;;    This file contains impelemtentation-dependent transforms.
  17. ;;;
  18. ;;; Written by Rob MacLachlan
  19. ;;;
  20. (in-package "C")
  21.  
  22. ;;; We need to define these predicates, since the TYPEP source transform picks
  23. ;;; whichever predicate was defined last when there are multiple predicates for
  24. ;;; equivalent types.
  25. ;;;
  26. (def-source-transform short-float-p (x) `(single-float-p ,x))
  27. (def-source-transform long-float-p (x) `(double-float-p ,x))
  28.  
  29. (def-source-transform compiled-function-p (x)
  30.   `(functionp ,x))
  31.  
  32. (def-source-transform char-int (x)
  33.   `(char-code ,x))
  34.  
  35. (deftransform abs ((x) (rational))
  36.   '(if (< x 0) (- x) x))
  37.  
  38.  
  39.  
  40. (macrolet ((frob (name primitive)
  41.          `(def-source-transform ,name (&rest foo)
  42.         `(truly-the nil
  43.                 (%primitive ,',primitive ,@foo)))))
  44.   (frob %type-check-error type-check-error)
  45.   (frob %odd-keyword-arguments-error odd-keyword-arguments-error)
  46.   (frob %unknown-keyword-argument-error unknown-keyword-argument-error)
  47.   (frob %argument-count-error argument-count-error))
  48.  
  49.  
  50. (def-source-transform %more-arg-context (&rest foo)
  51.   `(truly-the (values t fixnum) (%primitive more-arg-context ,@foo)))
  52. ;;;
  53. (def-source-transform %verify-argument-count (&rest foo)
  54.   `(%primitive verify-argument-count ,@foo))
  55.  
  56.  
  57.  
  58. ;;; Let these pass for now.
  59.  
  60. (def-primitive-translator header-ref (obj slot)
  61.   (warn "Someone used HEADER-REF.")
  62.   `(%primitive data-vector-ref/simple-vector ,obj ,slot))
  63.  
  64. (def-primitive-translator header-set (obj slot value)
  65.   (warn "Someone used HEADER-SET.")
  66.   `(%primitive data-vector-set/simple-vector ,obj ,slot ,value))
  67.  
  68. (def-primitive-translator header-length (obj)
  69.   (warn "Someone used HEADER-LENGTH.")
  70.   `(%primitive vector-length ,obj))
  71.  
  72.  
  73.  
  74. ;;;; Charater support.
  75.  
  76. ;;; There are really only base-chars.
  77. ;;;
  78. (def-source-transform characterp (obj)
  79.   `(base-char-p ,obj))
  80.  
  81. ;;; Keep this around in case someone uses it.
  82. ;;;
  83. (def-source-transform %string-char-p (obj)
  84.   (warn "Someone used %string-char-p.")
  85.   `(base-char-p ,obj))
  86.  
  87.  
  88.  
  89.  
  90. ;;;; Transforms for data-vector-ref for strange array types.
  91.  
  92. (deftransform data-vector-ref ((array index)
  93.                    (simple-array t))
  94.   (let ((array-type (continuation-type array)))
  95.     (unless (array-type-p array-type)
  96.       (give-up))
  97.     (let ((dims (array-type-dimensions array-type)))
  98.       (when (or (atom dims) (= (length dims) 1))
  99.     (give-up))
  100.       (let ((el-type (array-type-element-type array-type))
  101.         (total-size (if (member '* dims)
  102.                 '*
  103.                 (reduce #'* dims))))
  104.     `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
  105.                            (,total-size))
  106.                      (%array-data-vector array))
  107.               index)))))
  108.  
  109. (deftransform data-vector-set ((array index new-value)
  110.                    (simple-array t t))
  111.   (let ((array-type (continuation-type array)))
  112.     (unless (array-type-p array-type)
  113.       (give-up))
  114.     (let ((dims (array-type-dimensions array-type)))
  115.       (when (or (atom dims) (= (length dims) 1))
  116.     (give-up))
  117.       (let ((el-type (array-type-element-type array-type))
  118.         (total-size (if (member '* dims)
  119.                 '*
  120.                 (reduce #'* dims))))
  121.     `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
  122.                            (,total-size))
  123.                      (%array-data-vector array))
  124.               index
  125.               new-value)))))
  126.  
  127.  
  128. ;;; Transforms for getting at arrays of unsigned-byte n when n < 8.
  129.  
  130. #+nil
  131. (macrolet
  132.     ((frob (type bits)
  133.        (let ((elements-per-word (truncate vm:word-bits bits)))
  134.      `(progn
  135.         (deftransform data-vector-ref ((vector index)
  136.                        (,type *))
  137.           `(multiple-value-bind (word bit)
  138.                     (floor index ,',elements-per-word)
  139.          (ldb ,(ecase vm:target-byte-order
  140.              (:little-endian '(byte ,bits (* bit ,bits)))
  141.              (:big-endian '(byte ,bits (- vm:word-bits
  142.                               (* (1+ bit) ,bits)))))
  143.               (%raw-bits vector (+ word vm:vector-data-offset)))))
  144.         (deftransform data-vector-set ((vector index new-value)
  145.                        (,type * *))
  146.           `(multiple-value-bind (word bit)
  147.                     (floor index ,',elements-per-word)
  148.          (setf (ldb ,(ecase vm:target-byte-order
  149.                    (:little-endian '(byte ,bits (* bit ,bits)))
  150.                    (:big-endian
  151.                 '(byte ,bits (- vm:word-bits
  152.                         (* (1+ bit) ,bits)))))
  153.                 (%raw-bits vector (+ word vm:vector-data-offset)))
  154.                new-value)))))))
  155.   (frob simple-bit-vector 1)
  156.   (frob (simple-array (unsigned-byte 2) (*)) 2)
  157.   (frob (simple-array (unsigned-byte 4) (*)) 4))
  158.  
  159.  
  160.  
  161.  
  162. ;;;; Simple string transforms:
  163.  
  164. (defconstant vector-data-bit-offset (* vm:vector-data-offset vm:word-bits))
  165.  
  166. (deftransform subseq ((string start &optional (end nil))
  167.               (simple-string t &optional t))
  168.   '(let* ((length (- (or end (length string))
  169.              start))
  170.       (result (make-string length)))
  171.      (bit-bash-copy string
  172.             (+ (* start vm:byte-bits) vector-data-bit-offset)
  173.             result
  174.             vector-data-bit-offset
  175.             (* length vm:byte-bits))
  176.      result))
  177.  
  178.  
  179. (deftransform copy-seq ((seq) (simple-string))
  180.   '(let* ((length (length seq))
  181.       (res (make-string length)))
  182.      (bit-bash-copy seq
  183.             vector-data-bit-offset
  184.             res
  185.             vector-data-bit-offset
  186.             (* length vm:byte-bits))
  187.      res))
  188.  
  189.  
  190. (deftransform replace ((string1 string2 &key (start1 0) (start2 0)
  191.                 end1 end2)
  192.                (simple-string simple-string &rest t))
  193.   '(progn
  194.      (bit-bash-copy string2
  195.             (+ (* start2 vm:byte-bits) vector-data-bit-offset)
  196.             string1
  197.             (+ (* start1 vm:byte-bits) vector-data-bit-offset)
  198.             (* (min (- (or end1 (length string1))
  199.                    start1)
  200.                 (- (or end2 (length string2))
  201.                    start2))
  202.                vm:byte-bits))
  203.      string1))
  204.  
  205.  
  206. (deftransform concatenate ((rtype &rest sequences)
  207.                (t &rest simple-string)
  208.                simple-string)
  209.   (collect ((lets)
  210.         (forms)
  211.         (all-lengths)
  212.         (args))
  213.     (dolist (seq sequences)
  214.       (declare (ignore seq))
  215.       (let ((n-seq (gensym))
  216.         (n-length (gensym)))
  217.     (args n-seq)
  218.     (lets `(,n-length (* (length ,n-seq) vm:byte-bits)))
  219.     (all-lengths n-length)
  220.     (forms `(bit-bash-copy ,n-seq vector-data-bit-offset
  221.                    res start
  222.                    ,n-length))
  223.     (forms `(setq start (+ start ,n-length)))))
  224.     `(lambda (rtype ,@(args))
  225.        (declare (ignore rtype))
  226.        (let* (,@(lets)
  227.           (res (make-string (truncate (+ ,@(all-lengths)) vm:byte-bits)))
  228.           (start vector-data-bit-offset))
  229.      (declare (type index start ,@(all-lengths)))
  230.      ,@(forms)
  231.      res))))
  232.  
  233.  
  234. ;;;; Bit vector hackery:
  235.  
  236.  
  237. ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that
  238. ;;; does 32 bits at a time.
  239. ;;;
  240. (loop for (bitfun wordfun) in 
  241.   '((bit-and 32bit-logical-and)
  242.     (bit-ior 32bit-logical-or)
  243.     (bit-xor 32bit-logical-xor)
  244.     (bit-eqv 32bit-logical-eqv)
  245.     (bit-nand 32bit-logical-nand)
  246.     (bit-nor 32bit-logical-nor)
  247.     (bit-andc1 32bit-logical-andc1)
  248.     (bit-andc2 32bit-logical-andc2)
  249.     (bit-orc1 32bit-logical-orc1)
  250.     (bit-orc2 32bit-logical-orc2)) do
  251.   (deftransform bitfun
  252.         ((bit-array-1 bit-array-2 result-bit-array)
  253.          '(simple-bit-vector simple-bit-vector simple-bit-vector) '*
  254.          :eval-name t  :node node  :policy (>= speed space))
  255.     `(progn
  256.        ,@(unless (policy node (zerop safety))
  257.        '((unless (= (length bit-array-1) (length bit-array-2)
  258.             (length result-bit-array))
  259.            (error "Argument and/or result bit arrays not the same length:~
  260.                ~%  ~S~%  ~S  ~%  ~S"
  261.               bit-array-1 bit-array-2 result-bit-array))))
  262.        (do ((index vm:vector-data-offset (1+ index))
  263.         (end (+ vm:vector-data-offset
  264.             (truncate (the index
  265.                    (+ (length bit-array-1)
  266.                       vm:word-bits -1))
  267.                   vm:word-bits))))
  268.        ((= index end) result-bit-array)
  269.      (declare (optimize (speed 3) (safety 0))
  270.           (type index index end))
  271.      (setf (%raw-bits result-bit-array index)
  272.            (,wordfun (%raw-bits bit-array-1 index)
  273.              (%raw-bits bit-array-2 index)))))))
  274.  
  275. (deftransform bit-not
  276.           ((bit-array result-bit-array)
  277.            (simple-bit-vector simple-bit-vector) *
  278.            :node node  :policy (>= speed space))
  279.   `(progn
  280.      ,@(unless (policy node (zerop safety))
  281.      '((unless (= (length bit-array)
  282.               (length result-bit-array))
  283.          (error "Argument and result bit arrays not the same length:~
  284.                   ~%  ~S~%  ~S"
  285.             bit-array result-bit-array))))
  286.      (do ((index vm:vector-data-offset (1+ index))
  287.       (end (+ vm:vector-data-offset
  288.           (truncate (the index
  289.                  (+ (length bit-array)
  290.                     (1- vm:word-bits)))
  291.                 vm:word-bits))))
  292.      ((= index end) result-bit-array)
  293.        (declare (optimize (speed 3) (safety 0))
  294.         (type index index end))
  295.        (setf (%raw-bits result-bit-array index)
  296.          (32bit-logical-not (%raw-bits bit-array index))))))
  297.  
  298.  
  299. ;;;; Primitive translator for byte-blt
  300.  
  301.  
  302. (def-primitive-translator byte-blt (src src-start dst dst-start dst-end)
  303.   `(let ((src ,src)
  304.      (src-start (* ,src-start vm:byte-bits))
  305.      (dst ,dst)
  306.      (dst-start (* ,dst-start vm:byte-bits))
  307.      (dst-end (* ,dst-end vm:byte-bits)))
  308.      (let ((length (- dst-end dst-start)))
  309.        (etypecase src
  310.      (system-area-pointer
  311.       (etypecase dst
  312.         (system-area-pointer
  313.          (system-area-copy src src-start dst dst-start length))
  314.         ((simple-unboxed-array (*))
  315.          (copy-from-system-area src src-start
  316.                     dst (+ dst-start vector-data-bit-offset)
  317.                     length))))
  318.      ((simple-unboxed-array (*))
  319.       (etypecase dst
  320.         (system-area-pointer
  321.          (copy-to-system-area src (+ src-start vector-data-bit-offset)
  322.                   dst dst-start
  323.                   length))
  324.         ((simple-unboxed-array (*))
  325.          (bit-bash-copy src (+ src-start vector-data-bit-offset)
  326.                 dst (+ dst-start vector-data-bit-offset)
  327.                 length))))))))
  328.  
  329. ;;;; SXHASH:
  330.  
  331. ;;; Should be in VM:
  332.  
  333. (defconstant sxhash-bits-byte (byte 23 0))
  334. (defconstant sxmash-total-bits 26)
  335. (defconstant sxmash-rotate-bits 7)
  336.  
  337. (deftransform sxhash ((s-expr) (integer))
  338.   '(ldb sxhash-bits-byte s-expr))
  339.  
  340. (deftransform sxhash ((s-expr) (simple-string))
  341.   '(%sxhash-simple-string s-expr))
  342.  
  343. (deftransform sxhash ((s-expr) (symbol))
  344.   (%sxhash-simple-string (symbol-name s-expr)))
  345.  
  346. (deftransform sxhash ((s-expr) (single-float))
  347.   '(let ((bits (single-float-bits s-expr)))
  348.      (ldb sxhash-bits-byte
  349.       (logxor (ash bits (- sxmash-rotate-bits))
  350.           bits))))
  351.  
  352. (deftransform sxhash ((s-expr) (double-float))
  353.   '(let* ((val s-expr)
  354.       (lo (double-float-low-bits val))
  355.       (hi (double-float-high-bits val)))
  356.      (ldb sxhash-bits-byte
  357.       (logxor (ash lo (- sxmash-rotate-bits))
  358.           (ash hi (- sxmash-rotate-bits))
  359.           lo hi))))
  360.